home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / link / generate-c-header.scm < prev    next >
Text File  |  1995-10-13  |  5KB  |  153 lines
  1.  
  2. ; [This is a kludge.  Richard is loathe to include it in the
  3. ; distribution.]
  4.  
  5. ; Reads arch.scm and data.scm and writes out a C .h file with constants
  6. ; and macros for dealing with Scheme 48 data structures.
  7.  
  8. ; Needs Big Scheme.
  9.  
  10. ; (make-c-header-file "scheme48.h" "vm/arch.scm" "vm/data.scm")
  11.  
  12. (define (make-c-header-file c-file arch-file data-file)
  13.   (receive (stob-list stob-data)
  14.       (search-file arch-file
  15.            '("stob enumeration" "(define stob-data ...)")
  16.            (defines-enum? 'stob)
  17.            enum-definition-list
  18.            (lambda (x)
  19.              (and (eq? (car x) 'define)
  20.               (eq? (cadr x) 'stob-data)))
  21.            (lambda (x) (cadr (caddr x))))
  22.     (receive (tag-list immediate-list)
  23.     (search-file data-file
  24.              '("tag enumeration" "imm enumeration")
  25.              (defines-enum? 'tag)
  26.              enum-definition-list
  27.              (defines-enum? 'imm)
  28.              enum-definition-list)
  29.       (with-output-to-file c-file
  30.     (lambda ()
  31.       (format #t "typedef long scheme_value;~%~%")
  32.       (tag-stuff tag-list)
  33.       (newline)
  34.       (immediate-stuff immediate-list)
  35.       (newline)
  36.       (stob-stuff stob-list stob-data))))))
  37.       
  38. (define (tag-stuff tag-list)
  39.   (do ((tags tag-list (cdr tags))
  40.        (i 0 (+ i 1)))
  41.       ((null? tags))
  42.     (let ((name (upcase (car tags))))
  43.       (c-define "~A_TAG ~D" name i)
  44.       (c-define "~AP(x) (((long)(x) & 3L) == ~A_TAG)" name name)))
  45.   (newline)
  46.   (c-define "ENTER_FIXNUM(n)   ((scheme_value)((n) << 2))")
  47.   (c-define "EXTRACT_FIXNUM(x) ((long)(x) >> 2)"))
  48.  
  49. (define (immediate-stuff imm-list)
  50.   (c-define "MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))")
  51.   (do ((imm imm-list (cdr imm))
  52.        (i 0 (+ i 1)))
  53.       ((null? imm))
  54.     (let ((name (upcase (car imm))))
  55.       (c-define "SCH~A    MISC_IMMEDIATE(~D)" name i)))
  56.   (c-define "UNDEFINED SCHUNDEFINED")
  57.   (c-define "UNSPECIFIC SCHUNSPECIFIC")
  58.   (newline)
  59.   (c-define "ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)")
  60.   (c-define "EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)")
  61.   (newline)
  62.   (c-define "ENTER_CHAR(c) (SCHCHAR | ((c) << 8))")
  63.   (c-define "EXTRACT_CHAR(x) ((x) >> 8)"))
  64.  
  65. (define (stob-stuff stob-list stob-data)
  66.   (let ((type-mask (let ((len (length stob-list)))
  67.              (do ((i 2 (* i 2)))
  68.              ((>= i len) (- i 1))))))
  69.     (c-define "ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))")
  70.     (c-define "STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])")
  71.     (c-define "STOB_TYPE(x)   ((STOB_HEADER(x)>>2)&~D)" type-mask)
  72.     (c-define "STOB_HEADER(x) (STOB_REF((x),-1))")
  73.     (c-define "STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)")
  74.     (c-define "STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)")
  75.     (newline)
  76.     (do ((stob stob-list (cdr stob))
  77.      (i 0 (+ i 1)))
  78.     ((null? stob))
  79.       (let ((name (upcase (car stob))))
  80.     (c-define "STOBTYPE_~A ~D" name i)
  81.     (c-define "~AP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_~A))"
  82.           name name)))
  83.     (newline)
  84.     (for-each (lambda (data)
  85.         (do ((accs (cdddr data) (cdr accs))
  86.              (i 0 (+ i 1)))
  87.             ((null? accs))
  88.           (let ((name (upcase (caar accs))))
  89.             (c-define "~A(x) STOB_REF(x, ~D)" name i))))
  90.           stob-data)
  91.     (newline)
  92.     (c-define "VECTOR_LENGTH(x) STOB_LLENGTH(x)")
  93.     (c-define "VECTOR_REF(x, i) STOB_REF(x, i)")
  94.     (c-define "CODE_VECTOR_LENGTH(x)  STOB_BLENGTH(x)")
  95.     (c-define "CODE_VECTOR_REF(x, i)  (ADDRESS_AFTER_HEADER(x, unsigned char)[i])")
  96.     (c-define "STRING_LENGTH(x)  (STOB_BLENGTH(x)-1)")
  97.     (c-define "STRING_REF(x, i)  (ADDRESS_AFTER_HEADER(x, char)[i])")))
  98.  
  99. ; - becomes _ and > becomes TO_ (so -> turns into _TO_)
  100.  
  101. (define (upcase symbol)
  102.   (do ((chars (string->list (symbol->string symbol)) (cdr chars))
  103.        (res '() (case (car chars)
  104.           ((#\>) (append (string->list "_OT") res))
  105.           ((#\-) (cons #\_ res))
  106.           (else (cons (char-upcase (car chars)) res)))))
  107.       ((null? chars)
  108.        (list->string (reverse res)))))
  109.  
  110. (define (c-define string . stuff)
  111.   (format #t "#define ~?~%" string stuff))
  112.     
  113. (define (defines-enum? name)
  114.   (lambda (x)
  115.     (and (eq? (car x) 'define-enumeration)
  116.      (eq? (cadr x) name))))
  117.  
  118. (define enum-definition-list caddr)
  119.  
  120. ; STUFF is list of ((predicate . extract) . name).  <name> is replaced
  121. ; with the value when it is found.
  122.  
  123. (define (search-file file what-for . pred+extract)
  124.   (let ((stuff (do ((p+e pred+extract (cddr p+e))
  125.             (names what-for (cdr names))
  126.             (ps '() (cons (cons (cons (car p+e) (cadr p+e))
  127.                     (car names))
  128.                   ps)))
  129.            ((null? p+e) (reverse ps)))))
  130.  
  131.     (define (search next not-found)
  132.       (let loop ((n-f not-found) (checked '()))
  133.     (cond ((null? n-f)
  134.            #f)
  135.           (((caaar n-f) next)
  136.            (set-cdr! (car n-f) ((cdaar n-f) next))
  137.            (append (reverse checked) (cdr n-f)))
  138.           (else
  139.            (loop (cdr n-f) (cons (car n-f) checked))))))
  140.  
  141.     (with-input-from-file file
  142.       (lambda ()
  143.     (let loop ((not-found stuff))
  144.       (let ((next (read)))
  145.         (cond ((null? not-found)
  146.            (apply values (map cdr stuff)))
  147.           ((eof-object? next)
  148.            (error "file ~S doesn't have ~A" file (cdar not-found)))
  149.           (else
  150.            (loop (or (and (pair? next)
  151.                   (search next not-found))
  152.                  not-found))))))))))
  153.